home *** CD-ROM | disk | FTP | other *** search
/ TOS Silver 2000 / TOS Silver 2000.iso / programm / MM2_DEV / S / MYUTIL / DMA.M < prev    next >
Encoding:
Text File  |  1994-06-03  |  31.0 KB  |  1,028 lines
  1. MODULE DMA;
  2. (*$Q+,G+,C-*)
  3.  
  4. (* Module Version V#052, Gdos /1.3l/, Begonnen: 19.12.85 *)
  5. (* (c) 1985 by Frank Mersmann                            *)
  6.  
  7. (*
  8.   08.10.90 - berücksichtigt nun auch DLE-Codes
  9.   18.12.90 - kommt mit absolut definierten Vars klar
  10.   25.05.94 - "IMPORT Bla, Fasel;" statt nur "IMPORT BlaBla;" von Gerd Castan
  11.   28.05.94 - folgende Typdeklaration fuehrt nicht mehr zu einem Fehler:
  12.              TYPE    BCONMAP = POINTER TO
  13.                        RECORD
  14.                         maptab:     POINTER TO ARRAY [0..5] OF PROC;
  15.                         maptabsize: sINTEGER;
  16.                        END;
  17.              Gerd Castan -> Version 1.4
  18.   
  19.   HINWEISE:
  20.    - Der Stack sollte 100 KB groß sein,
  21.    - das Prg sollte gelinkt werden, weil sonst nicht genug Speicher bei
  22.      2MB vorhanden ist.
  23.    - SimpleError sollte wg. HALT-Aufrufen mitgelinkt werden
  24.    - Die Module GEMShare, ModBase, MOSCtrl und Runtime sollten nicht geparsed
  25.      werden, weil die Arbeit, sie zu entfernen, groß ist.
  26. *)
  27.  
  28. (* Programm Kurzbeschreibung
  29.    -------------------------
  30.    
  31.    Wer kennt nicht die folgende Situation:
  32.    Eine bestimmte Variable oder eine bestimmte Procedure soll importiert
  33.    werden, aber der Identifier ist nicht genau bekannt. Heisst die Variable
  34.    nun MaxString oder MaxStr und wird sie aus Strings oder aus GdosTypes
  35.    importiert. Hat FileOpen 3, 4 oder 5 Parameter usw.
  36.    Dann beginnt die grosse Suchaktion in diversen Listings (hoffentlich
  37.    richtige Version).
  38.    
  39.    DMA kann evtl. Abhilfe schaffen. Das Programm erzeugt eine geordnete
  40.    Liste aller exportierten Identifier.
  41.    
  42.                               DMA erwartet, dass alle im System benutzten
  43.    Module als Definition Module Textfiles (xxxx-.Text) auf dem Prefix
  44.    Volume vorhanden sind. Nach Start merkt es sich alle Eintraege der Ex-
  45.    portlisten und notiert, ob es sich um Const, Type, Var oder Proceduren
  46.    handelt. Im letzten Fall wird soviel wie moeglich vom Procedureaufruf
  47.    (Parameter) notiert. Die exportierten Identifier werden alphabetisch
  48.    sortiert und koennen anschliessend auf dem Bildschirm, Drucker, serieller
  49.    Schnittstelle oder dem File :DMA.Result.Text ausgegeben werden. Mit
  50.    der so erstellten Liste reduzieren sich die Suchzeiten erheblich.
  51.    
  52.    
  53.    Bemerkung 1: Das Programm enthaelt sicher noch den einen oder anderen
  54.                 Fehler, da es in grosser Eile geschrieben wurde. Fuer Hin-
  55.                 weise waere ich dankbar.
  56.    
  57.    Bemerkung 2: Das Programm ist nicht auf Geschwindigkeit getrimmt. Dazu
  58.                 haette man verschiedene Teile in Assembler schreiben und
  59.                 auf Rekursion verzichten muessen. Es ist aber ein gutes
  60.                 Beispiel, wie elegant man bestimmte Probleme (PutInList,
  61.                 GetSymbol) mit einer Hochsprache wie Modula-2 loesen kann.
  62. *)
  63.  
  64. IMPORT TOSIO;
  65.  
  66. FROM Storage            IMPORT  Allocate,
  67.                                 DeAllocate,
  68.                                 memavail;
  69. FROM Strings            IMPORT  Append,
  70.                                 DelTrailingBlanks,
  71.                                 Assign,
  72.                                 Space,
  73.                                 String,
  74.                                 Concat,
  75.                                 Copy,
  76.                                 Upper,
  77.                                 Delete,
  78.                                 StrEqual,
  79.                                 Empty,
  80.                                 Length,
  81.                                 Relation,
  82.                                 Compare;
  83. IMPORT FastStrings;
  84. FROM FuncStrings IMPORT UpStr;
  85. FROM Files              IMPORT  GetStateMsg,
  86.                                 File,
  87.                                 Access,
  88.                                 State,
  89.                                 ResetState,
  90.                                 Open,
  91.                                 Close,
  92.                                 Remove,
  93.                                 Create,
  94.                                 ReplaceMode;
  95. FROM Binary             IMPORT  FileSize,
  96.                                 ReadBytes;
  97. FROM InOut              IMPORT  WritePg,
  98.                                 Read,
  99.                                 ReadCard,
  100.                                 WriteString,
  101.                                 WriteCard,
  102.                                 ReadString,
  103.                                 Write,
  104.                                 WriteLn;
  105. IMPORT Text;
  106. FROM Directory          IMPORT  DirEntry,
  107.                                 FileAttrSet,
  108.                                 DirQuery;
  109.  
  110.  
  111.  
  112. CONST   maxkey        = 17;
  113.         Version       = '/1.4 Atari/';
  114.         
  115.         TAB = CHR (9);
  116.  
  117. TYPE    MaxStr        = ARRAY [0..127] OF CHAR;
  118.         IdStr         = ARRAY [0..29] OF CHAR;
  119.  
  120.         tKeySize      = [0..maxkey];
  121.         
  122.         tSymbol       = (null, eql, comma, rparen, lparen, rbrack, lbrack,
  123.                          lset, rset, number, ident, colon, semicolon, endid,
  124.                          ofid, arrayid, recordid, caseid, setid, pointerid,
  125.                          beginid, constid, enumid, typeid, varid, procid,
  126.                          defid, modid, period, fromid, importid, expid,
  127.                          qualid, pervid, eof);
  128.         
  129.         tCharsSet     = SET OF CHAR;
  130.         
  131.         tKeyRec       = RECORD
  132.                           KeyWord : IdStr;
  133.                           Symbol  : tSymbol
  134.                         END;
  135.         
  136.         tKeyArray     = ARRAY tKeySize OF tKeyRec;
  137.         
  138.         tExIdPtr      = POINTER TO tExLiIdent;
  139.         tExLiIdent    = RECORD
  140.                           Ident       : IdStr;
  141.                           UpIdent     : IdStr;
  142.                           ModIdent    : IdStr;
  143.                           ProcHeading : MaxStr;
  144.                           ObjClass    : tSymbol;
  145.                           NextId      : tExIdPtr
  146.                         END;
  147.         
  148.         tBlockBuf     = ARRAY [0..511] OF WORD;
  149.  
  150. CONST   TestFlag = FALSE;        (* TRUE: gelesene Chars ausgeben *)
  151.  
  152. VAR     ok            : BOOLEAN;        (* Für String-Funktionsergebnisse *)
  153.         BufInx,                         (* Index in Block Buffer *)
  154.         i,
  155.         ZeilCnt,
  156.         DirInx,
  157.         Laenge,                         (* des Input Files *)
  158.         LastDirInx,
  159.         RelBlk        : CARDINAL;       (* Position in Infile *)
  160.         BufHigh       : LONGCARD;       (* Belegte Bytes in Read-Buffer *)
  161.         GlobCh, LastCh: CHAR;           (* letzter gelesener Char aus File *)
  162.         GetAgain      : BOOLEAN;
  163.         DefModIdent   : IdStr;          (* Name des Definition Modules *)
  164.         IdentBuf      : IdStr;          (* letzter gelesener Identifier *)
  165.         NumberBuf     : String;         (* letzte gelesene Zahl(en) *)
  166.         InFile        : File;
  167.         GlobSym       : tSymbol;        (* letztes gelesenes Symbol *)
  168.         ExIdRootPtr   : tExIdPtr;       (* Root^ der Liste *)
  169.         KeyArray      : tKeyArray;      (* zu untersuchende Schluesselworte *)
  170.         BlockBuf      : tBlockBuf;      (* Text Puffer *)
  171.         DiEntry       : DirEntry;
  172.  
  173. CONST
  174.     IdChars   = tCharsSet {'0'..'9', 'A'..'Z', '_', 'a'..'z', '@'};
  175.     NumChars  = tCharsSet {'+', '-', '0'..'9', 'E', 'e'};
  176.  
  177.  
  178.   PROCEDURE Init () : BOOLEAN;
  179.   (* Einmalige Initialisierung *)
  180.   
  181.   VAR   ch            : CHAR;
  182.   
  183.   BEGIN
  184.     WritePg;
  185.     WriteString (Space(19));
  186.     WriteString ('Definition Module Analyzer ');
  187.     WriteString (Version);     Writeln;
  188.     WriteString (Space(19));
  189.     Writeln;
  190.     Writeln;
  191.     WriteString ('Create an ordered List of all exported Objects');
  192.     Writeln;
  193.     Writeln;
  194.     
  195.     KeyArray[0].KeyWord := 'DEFINITION';
  196.     KeyArray[0].Symbol  := defid;
  197.     KeyArray[1].KeyWord := 'MODULE';
  198.     KeyArray[1].Symbol  := modid;
  199.     KeyArray[2].KeyWord := 'FROM';
  200.     KeyArray[2].Symbol  := fromid;
  201.     KeyArray[3].KeyWord := 'IMPORT';
  202.     KeyArray[3].Symbol  := importid;
  203.     KeyArray[4].KeyWord := 'EXPORT';
  204.     KeyArray[4].Symbol  := expid;
  205.     KeyArray[5].KeyWord := 'QUALIFIED';
  206.     KeyArray[5].Symbol  := qualid;
  207.     KeyArray[6].KeyWord := 'CONST';
  208.     KeyArray[6].Symbol  := constid;
  209.     KeyArray[7].KeyWord := 'TYPE';
  210.     KeyArray[7].Symbol  := typeid;
  211.     KeyArray[8].KeyWord := 'VAR';
  212.     KeyArray[8].Symbol  := varid;
  213.     KeyArray[9].KeyWord := 'PROCEDURE';
  214.     KeyArray[9].Symbol  := procid;
  215.     KeyArray[10].KeyWord := 'END';
  216.     KeyArray[10].Symbol  := endid;
  217.     KeyArray[11].KeyWord := 'ARRAY';
  218.     KeyArray[11].Symbol  := arrayid;
  219.     KeyArray[12].KeyWord := 'OF';
  220.     KeyArray[12].Symbol  := ofid;
  221.     KeyArray[13].KeyWord := 'RECORD';
  222.     KeyArray[13].Symbol  := recordid;
  223.     KeyArray[14].KeyWord := 'SET';
  224.     KeyArray[14].Symbol  := setid;
  225.     KeyArray[15].KeyWord := 'POINTER';
  226.     KeyArray[15].Symbol  := pointerid;
  227.     KeyArray[16].KeyWord := 'CASE';
  228.     KeyArray[16].Symbol  := caseid;
  229.     KeyArray[17].KeyWord := 'PERVASIVE';
  230.     KeyArray[17].Symbol  := pervid;
  231.     
  232.     ExIdRootPtr := NIL;
  233.     RETURN TRUE
  234.   END Init;
  235.   
  236.   
  237.   PROCEDURE InitNewDefMod;
  238.   (* Initialisierung fuer jedes neue File *)
  239.   BEGIN
  240.     RelBlk := 0;
  241.     GlobCh := ' ';
  242.     GlobSym := null;
  243.   END InitNewDefMod;
  244.   
  245.   
  246.   PROCEDURE Error (nummer:INTEGER);
  247.   (* Nicht interessant, wenn der Compiler Def Modul uebersetzen kann *)
  248.   VAR   s             : String;
  249.   
  250.   BEGIN
  251.     IF nummer < 0 THEN
  252.         Writeln;
  253.         Writeln;
  254.         WriteString ('Zeile ');
  255.         WriteCard (ZeilCnt, 0);
  256.         Write (':');
  257.         Writeln;
  258.         IF Nummer > -200 THEN
  259.           GetStateMsg (nummer,s);
  260.         ELSE
  261.           WriteString ('DMA Syntax Error: ');
  262.           CASE Nummer OF
  263.             -200 : s := 'DEFINITION MODULE declaration expected' |
  264.             -201 : s := 'END ident. expected' |
  265.             -202 : s := 'Identifier expected' |
  266.             -203 : s := '";" expected' |
  267.             -204 : s := 'QUALIFIED expected'
  268.           END
  269.         END;
  270.         
  271.         WriteString (s);
  272.         Writeln;
  273.         Halt
  274.     END
  275.   END Error;
  276.   
  277.   
  278.   PROCEDURE OpenFile (FileName : String);
  279.   (* Erstes / naechstes Textfile oeffnen *)
  280.   BEGIN
  281.     Open (InFile, FileName, readOnly);
  282.     Error (state(infile));
  283.     Laenge:= SHORT (FileSize (InFile) DIV 1024L)
  284.              + ORD ( SHORT (FileSize (InFile) MOD 1024L) # 0);
  285.     WriteString ('... parsing ');
  286.     WriteString (FileName);
  287.     ZeilCnt:= 1;
  288.     (*$? TestFlag:
  289.       WriteLn;
  290.       WriteString ('Länge: ');
  291.       WriteCard (Laenge,0);
  292.       WriteString (' Blocks');
  293.     *)
  294.     Writeln;
  295.   END OpenFile;
  296.   
  297.   
  298.   PROCEDURE ReadFile;
  299.   (* Naechsten Block in Buffer einlesen *)
  300.   BEGIN
  301.     ReadBytes (InFile, ADR (BlockBuf), 1024, BufHigh);
  302.     (*$? TestFlag:
  303.       WriteLn;
  304.       WriteString ('Read block ');
  305.       WriteCard (relBlk,0);
  306.       WriteString (', ');
  307.       WriteCard (BufHigh,0);
  308.       WriteString (' bytes.');
  309.       WriteLn;
  310.     *)
  311.     Error (State (infile));
  312.     Inc (RelBlk);
  313.     BufInx := 0
  314.   END ReadFile;
  315.   
  316.   
  317.   PROCEDURE FindIdent (    RootPtr : tExIdPtr;
  318.                        VAR FindPtr : tExIdPtr;
  319.                            FindId  : IdStr) : BOOLEAN;
  320.   (* Suche den Eintrag FindId in der Liste. Gross / klein wird
  321.      nicht unterschieden *)
  322.   VAR ch: CHAR;
  323.   BEGIN
  324.     FindPtr := RootPtr;
  325.     Upper (FindId);
  326.     ch:= FindId [0];
  327.     LOOP
  328.       IF FindPtr = NIL THEN RETURN FALSE END;
  329.       IF FindPtr^.UpIdent[0] = ch THEN
  330.         IF Compare (FindPtr^.UpIdent, FindId) = equal THEN
  331.           RETURN TRUE
  332.         END
  333.       END;
  334.       FindPtr := FindPtr^.NextId
  335.     END;
  336.   END FindIdent;
  337.   
  338.   
  339.   PROCEDURE List;
  340.   (* Sortierte Liste auf verschiednen Units ausgeben *)
  341.   VAR   i, width, mwidth, lines: CARDINAL;
  342.         ch, tch       : CHAR;
  343.         tabs          : BOOLEAN;
  344.         OutName       : String;
  345.         OutStr        : MaxStr;
  346.         outf          : File;
  347.         ListPtr       : tExIdPtr;
  348.         
  349.   BEGIN
  350.     REPEAT
  351.       Writeln;
  352.       WriteString ('Select Unit for ordered List');
  353.       Writeln;
  354.       Writeln;
  355.       WriteString ('C)RT,  F)ile,  P)rinter,  S)erial,  Q)uit ?');
  356.       Read (ch);
  357.       Writeln;
  358.       
  359.       CASE Cap (ch) OF
  360.         'F' : WriteString ('Filename? ');
  361.               ReadString (OutName);
  362.               Writeln |
  363.         'P' : OutName := 'PRN:' |
  364.         'Q' : |
  365.         'S' : OutName := 'AUX:'|
  366.       ELSE
  367.         OutName := 'CON:'
  368.       END;
  369.       
  370.       IF Cap (ch) # 'Q' THEN
  371.  
  372.         Writeln;
  373.         WriteString ('Separate lines by TABs? (Y/n) ');
  374.         Read (tch);
  375.         tabs:= CAP (tch) # 'N';
  376.         Writeln;
  377.         
  378.         WriteString ('Lines per side/screen? (0 means no FF) ');
  379.         ReadCard (lines);
  380.         
  381.         WriteString ('Max length of lines? (0 means infinite) ');
  382.         ReadCard (width);
  383.         Writeln;
  384.  
  385.         Create (outf, OutName, writeSeqTxt, replaceOld);
  386.         
  387.         (*
  388.          * Zuerst einmal die Breite der Modulnamen bestimmen
  389.          *)
  390.         IF NOT tabs THEN
  391.           ListPtr := ExIdRootPtr;
  392.           mwidth:= 0;
  393.           WHILE ListPtr # NIL DO
  394.             IF mwidth < Length (ListPtr^.ModIdent) THEN
  395.               mwidth:= Length (ListPtr^.ModIdent);
  396.             END;
  397.             ListPtr := ListPtr^.NextId
  398.           END;
  399.         END;
  400.         INC (mwidth);
  401.         IF width > 0 THEN
  402.           DEC (width, mwidth + 2);
  403.         ELSE
  404.           width:= MAX (CARDINAL)
  405.         END;
  406.         
  407.         i:= 0;
  408.         ListPtr := ExIdRootPtr;
  409.         WHILE ListPtr # NIL DO
  410.           Assign (ListPtr^.ModIdent, OutStr, ok);
  411.           Text.WriteString (outf, OutStr);
  412.           IF tabs THEN
  413.             Text.Write (outf, TAB)
  414.           ELSE
  415.             Text.WriteString (outf, Space (mwidth - Length (outStr)));
  416.           END;
  417.           IF ListPtr^.ObjClass = procid THEN
  418.             Text.WriteString (outf, 'P');
  419.             IF tabs THEN Text.Write (outf, TAB) ELSE Text.Write (outf, ' '); END;
  420.             IF Length (ListPtr^.ProcHeading) > width THEN
  421.               FastStrings.Copy (ListPtr^.ProcHeading, 0, width-2, OutStr);
  422.               Append ('..', OutStr, ok)
  423.             ELSE
  424.               Assign (ListPtr^.ProcHeading, OutStr, ok)
  425.             END;
  426.             Text.WriteString (outf, OutStr)
  427.           ELSE
  428.             CASE ListPtr^.ObjClass OF
  429.               constid : Text.Write (outf, 'C') |
  430.               enumid  : Text.Write (outf, 'E') |
  431.               typeid  : Text.Write (outf, 'T') |
  432.               varid   : Text.Write (outf, 'V')
  433.             ELSE
  434.               Text.Write (outf, '?')
  435.             END;
  436.             IF tabs THEN Text.Write (outf, TAB) ELSE Text.Write (outf, ' '); END;
  437.             Text.WriteString (outf, ListPtr^.Ident)
  438.           END;
  439.           Text.Writeln (outf);
  440.           Inc (i);
  441.           
  442.           CASE Cap (ch) OF
  443.             'C' : IF (lines > 0) & (i MOD lines = 0) THEN
  444.                     Text.Writeln (outf);
  445.                     Text.WriteString (outf, 'type /SPACE/ to continue');
  446.                     Read (globch);
  447.                     Text.Writeln (outf);
  448.                     Text.Writeln (outf)
  449.                   END |
  450.             'F' : |
  451.             'P' : IF (lines > 0) & (i MOD lines = 0) THEN Text.Write (outf, 12C) END
  452.           ELSE
  453.           END;
  454.           
  455.           ListPtr := ListPtr^.NextId
  456.         END;
  457.         Close (outf)
  458.       END
  459.     UNTIL Cap (ch) = 'Q';
  460.   END List;
  461.   
  462.   
  463.   
  464.   (* ++++++++++ Die folgenden Proceduren gehoeren zum Scanner ++++++++++ *)
  465.   
  466.   PROCEDURE GetChar;
  467.   (*$L-*)
  468.   (* naechstes Zeichen aus Textbuffer einlesen. "Besonderheiten" des Editors
  469.      und alte UCSD-File-Nullen beruecksichtigen.
  470.   *)
  471.     PROCEDURE GetC;
  472.     BEGIN
  473.     ASSEMBLER
  474.     STARTGETC   LEA     BlockBuf,A0             ;^ auf Char Buffer *)
  475.                 MOVE.W  BufInx,D0               ;Offset in Char Buffer
  476.                 CLR.W   D1
  477.                 MOVE.B  00(A0,D0.W),D1
  478.                 ADDQ.W  #01,D0                  ;Index erhoehen
  479.                 MOVE.W  D0,BufInx               ;Index wieder ablegen
  480.                 MOVE.L  BufHigh,D2
  481.                 CMP.W   D2,D0                   ;kein Zeichen mehr da?
  482.                 BCS     ZEICHENDA
  483.                 MOVEM.W D0-D1,-(A7)
  484.                 JSR     ReadFile                ;naechsten 1024 Zeichen
  485.                 MOVEM.W (A7)+,D0-D1
  486.       ZEICHENDA
  487.     END
  488.     END GetC;
  489.     
  490.   BEGIN
  491.   ASSEMBLER
  492.                 TST     GetAgain
  493.                 BEQ     START
  494.                 CLR     GetAgain
  495.                 MOVE.B  LastCh,GlobCh
  496.                 BRA     ende
  497.   START         BSR     GetC
  498.                 TST.B   D1                      ;00 gelesen ?
  499.                 BEQ.S   MAKEBLANK
  500.                 CMP.B   #16,D1                  ;<DLE> gelesen ?
  501.                 BEQ.S   isdle
  502.                 CMP.B   #$0D,D1                 ;<CR> gelesen ?
  503.                 BEQ.S   zeile
  504.                 CMP.B   #$0A,D1                 ;<CR> gelesen ?
  505.                 BNE.S   KEINCRORDLE
  506.                 BRA.S   MAKEBLANK               ;nur bei CR ZeilCnt erhöhen
  507.   isdle         BSR     GetC
  508.                 BRA.S   MAKEBLANK
  509.   zeile         ADDQ    #1,ZeilCnt
  510.   MAKEBLANK     MOVE.B  #' ',D1                 ;durch Blank ersetzen
  511.   KEINCRORDLE   MOVE.B  D1,GlobCh               ;1 Char transferieren
  512.                 MOVE.B  D1,LastCh
  513.   ende
  514.   END;
  515.     (*$? TestFlag: Write (GlobCh) *)
  516.   END GetChar;
  517.   (*$L=*)
  518.   
  519.   
  520.   PROCEDURE Identifier;
  521.   (* Identifier zusammenbauen und pruefen, ob Keywort *)
  522.   VAR   Match         : BOOLEAN;
  523.         i             : CARDINAL;
  524.   
  525.   BEGIN
  526.     IdentBuf := '';
  527.     REPEAT
  528.       FastStrings.Append (GlobCh, IdentBuf);
  529.       GetChar
  530.     UNTIL NOT (GlobCh IN IdChars);
  531.  
  532.     i := 0;     Match := FALSE;
  533.     REPEAT
  534.       Match := StrEqual(IdentBuf, KeyArray[i].KeyWord);
  535.       Inc (i)
  536.     UNTIL Match OR (i > maxkey);
  537.     
  538.     IF Match
  539.       THEN GlobSym := KeyArray[i-1].Symbol
  540.       ELSE GlobSym := ident
  541.     END
  542.   END Identifier;
  543.   
  544.   
  545.   PROCEDURE Numbers;
  546.   (* Nummern zusammenbauen *)
  547.   BEGIN
  548.     NumberBuf := '';    GlobSym := number;
  549.     REPEAT
  550.       FastStrings.Append (GlobCh, NumberBuf);
  551.       GetChar
  552.     UNTIL NOT (GlobCh IN NumChars)
  553.   END Numbers;
  554.   
  555.   
  556.   PROCEDURE Comment;
  557.   (* Eleminiert auch verschachtelte Kommentare *)
  558.   BEGIN
  559.     REPEAT
  560.       WHILE GlobCh # '*' DO
  561.         IF GlobCh = '(' THEN
  562.           GetChar;
  563.           IF GlobCh = '*' THEN Comment END
  564.         ELSE
  565.           GetChar
  566.         END
  567.       END;
  568.       GetChar
  569.     UNTIL GlobCh = ')';
  570.     GetChar
  571.   END Comment;
  572.     
  573.     
  574.   PROCEDURE GetSymbol;
  575.   (* naechstes Symbol erkennen *)
  576.   BEGIN
  577.     LOOP        (* Schrott eleminieren *)
  578.       CASE GlobCh OF
  579.         0C         : IF RelBlk > Laenge
  580.                        THEN GlobCh := ' ';   EXIT
  581.                        ELSE GetChar
  582.                      END |
  583.         1C..' '    : GetChar |
  584.       ELSE
  585.         EXIT
  586.       END
  587.     END;  (* loop *)
  588.     
  589.     CASE GlobCh OF
  590.       ' '      : GlobSym := eof;        GlobCh := 0C |
  591.       '!'      : GlobSym := null;       GetChar |
  592.       '"'      : GlobSym := null;       GetChar |  (* ; *)
  593.       '$'      : Globsym := null;       GetChar |
  594.       '%'      : Globsym := null;       GetChar |
  595.       '&'      : Globsym := null;       GetChar |
  596.       "'"      : Globsym := null;       GetChar |
  597.       '('      : GetChar;
  598.                  IF GlobCh = '*'
  599.                    THEN Comment;        GetSymbol
  600.                    ELSE GlobSym := lparen
  601.                  END|
  602.       ')'      : GlobSym := rparen;     GetChar |
  603.       ','      : GlobSym := comma;      GetChar |
  604.       '.'      : GlobSym := period;     GetChar |
  605.       '0'..'9' : Numbers |
  606.       ':'      : GlobSym := colon;      GetChar |
  607.       ';'      : GlobSym := semicolon;  GetChar |
  608.       '='      : GlobSym := eql;        GetChar |
  609.       '_'      : Identifier |
  610.       '@'      : Identifier |
  611.       'A'..'Z' : Identifier |
  612.       '['      : GlobSym := lbrack;     GetChar |
  613.       ']'      : GlobSym := rbrack;     GetChar |
  614.       'a'..'z' : Identifier |
  615.       '{'      : GlobSym := lset;       GetChar |
  616.       '|'      : GlobSym := null;       GetChar |
  617.       '}'      : GlobSym := rset;       GetChar |
  618.       '~'      : GlobSym := null;       GetChar
  619.     ELSE
  620.                  Globsym := null;       GetChar
  621.     END
  622.   END GetSymbol;
  623.   
  624.   
  625.   
  626.   (* ++++++++++ Die folgenden Proceduren gehoeren zum Parser ++++++++++ *)
  627.   
  628.   
  629.   PROCEDURE Insert (VAR RootP : tExIdPtr; VAR NewP : tExIdPtr);
  630.   (* Do it, but do it recursive *)
  631.   BEGIN
  632.     IF RootP = NIL THEN
  633.       RootP := NewP
  634.     ELSIF less = Compare (RootP^.UpIdent, NewP^.UpIdent) THEN
  635.       Insert (RootP^.NextId, NewP)
  636.     ELSE
  637.       NewP^.NextId := RootP;
  638.       RootP := NewP
  639.     END
  640.   END Insert;
  641.  
  642.   PROCEDURE PutInList;
  643.   (* neuen Identifier in Liste einfuegen *)
  644.   VAR   NewPtr        : tExIdPtr;
  645.  
  646.   BEGIN
  647.     New (NewPtr);
  648.     IF NewPtr = NIL THEN
  649.       WriteString ('Out of memory!');
  650.       WriteLn;
  651.       HALT
  652.     END;
  653.     WITH NewPtr^ DO
  654.       Ident := IdentBuf;
  655.       UpIdent := Ident;
  656.       Upper (UpIdent);
  657.       ModIdent := DefModIdent;
  658.       ObjClass := null;
  659.       NextId := NIL
  660.     END;
  661.     Insert (ExIdRootPtr, NewPtr)
  662.   END PutInList;
  663.   
  664.   
  665.   PROCEDURE ConstDecl;
  666.   (* CONST - Deklarationen bearbeiten *)
  667.   VAR   FindPtr       : tExIdPtr;
  668.   
  669.   BEGIN
  670.     IF GlobSym = ident
  671.       THEN
  672.         WHILE GlobSym = ident DO
  673.           PutInList;
  674.           IF FindIdent (ExIdRootPtr, FindPtr, IdentBuf)
  675.             THEN FindPtr^.ObjClass := constid
  676.           END;
  677.           REPEAT GetSymbol UNTIL GlobSym = semicolon;
  678.           GetSymbol
  679.         END  (* while *)
  680.       ELSE Error (-202)
  681.     END
  682.   END ConstDecl;
  683.   
  684.   VAR   TypeName      : IdStr;  (* Name des aktuellen Typs *)
  685.   
  686.   PROCEDURE Types;
  687.   VAR   FindPtr       : tExIdPtr;
  688.   BEGIN
  689.     CASE GlobSym OF
  690.       lparen    : (* Aufzählungstyp *)
  691.                   GetSymbol;
  692.                   IF GlobSym = ident
  693.                     THEN
  694.                       WHILE GlobSym = ident DO
  695.                         Append (' - ', IdentBuf, ok);
  696.                         FastStrings.Append (TypeName, IdentBuf);
  697.                         PutInList;
  698.                         IF FindIdent (ExIdRootPtr, FindPtr, IdentBuf)
  699.                           THEN FindPtr^.ObjClass := enumid
  700.                         END;
  701.                         REPEAT GetSymbol UNTIL (GlobSym = comma) OR
  702.                                                (GlobSym = rparen);
  703.                         GetSymbol
  704.                       END  (* while *)
  705.                     ELSE Error (-202)
  706.                   END|
  707.       ident     : |
  708.       arrayid   : WHILE GlobSym # ofid DO GetSymbol END;  GetSymbol; Types; |
  709.       caseid,
  710.       recordid  : WHILE GlobSym # endid DO
  711.                     GetSymbol;
  712.                     IF (GlobSym = recordid) OR (GlobSym = caseid) THEN
  713.                       Types
  714.                     END
  715.                   END;
  716.                   GetSymbol |
  717.       setid     : |
  718.       pointerid : GetSymbol;      (* TO; Gerd Castan 28.05.94 *)
  719.                   GetSymbol;
  720.                   Types; |
  721.       procid    : IF GlobCh = '(' THEN
  722.                     WHILE GlobSym # rparen DO GetSymbol END
  723.                   END
  724.     ELSE
  725.     END;
  726.     (* semicolon ueberlesen: *)
  727.     WHILE (GlobSym # semicolon) & (GlobSym # endid) DO GetSymbol END
  728.   END Types;
  729.   
  730.   
  731.   PROCEDURE TypeDecl;
  732.   (* TYPE - Deklarationen bearbeiten *)
  733.   VAR   FindPtr       : tExIdPtr;
  734.   
  735.   BEGIN
  736.     IF GlobSym = ident
  737.       THEN
  738.         WHILE GlobSym = ident DO
  739.           PutInList;
  740.           IF FindIdent (ExIdRootPtr, FindPtr, IdentBuf)
  741.             THEN FindPtr^.ObjClass := typeid;
  742.             TypeName := IdentBuf; (* Namen dieses Typs merken *)
  743.           END;
  744.           GetSymbol;
  745.           IF GlobSym = eql THEN GetSymbol; Types END;
  746.           GetSymbol
  747.         END   (* while *)
  748.       ELSE Error (-202)
  749.     END
  750.   END TypeDecl;
  751.   
  752.   
  753.   PROCEDURE VarDecl;
  754.   (* VAR - Deklarationen bearbeiten *)
  755.   VAR   FindPtr       : tExIdPtr;
  756.   
  757.   BEGIN
  758.     IF GlobSym = ident THEN
  759.       WHILE GlobSym = ident DO
  760.         PutInList;
  761.         IF FindIdent (ExIdRootPtr, FindPtr, IdentBuf) THEN
  762.           FindPtr^.ObjClass := varid
  763.         END;
  764.         GetSymbol;
  765.         IF GlobSym = lbrack THEN
  766.           REPEAT
  767.             GetSymbol;
  768.           UNTIL GlobSym = rbrack;
  769.           GetSymbol;
  770.         END;
  771.         IF GlobSym = colon THEN GetSymbol; Types END;
  772.         GetSymbol
  773.       END  (* while *)
  774.     ELSE
  775.       Error (-202)
  776.     END
  777.   END VarDecl;
  778.   
  779.   PROCEDURE ProcDecl;
  780.   (* PROC - Deklarationen bearbeiten *)
  781.   VAR   ProcBuf       : MaxStr;
  782.         FindPtr       : tExIdPtr;
  783.   
  784.     PROCEDURE MyAppend;
  785.     VAR spc: BOOLEAN;
  786.     BEGIN
  787.       WHILE GlobCh = ' ' DO GetChar END; (* führende Leerz. weg *)
  788.       spc:= TRUE;
  789.       LOOP
  790.         CASE GlobCh OF
  791.           ' ' : (* nur ein Leerz. lassen wir zu *)
  792.                 IF NOT spc THEN
  793.                   Append (' ', ProcBuf, ok);
  794.                   spc:= TRUE
  795.                 END;
  796.                 GetChar|
  797.           '(' : GetChar;
  798.                 IF GlobCh = '*' THEN
  799.                   Comment
  800.                 ELSE
  801.                   GetAgain:= TRUE;
  802.                   GlobCh:= '(';
  803.                   spc:= FALSE;
  804.                   EXIT
  805.                 END|
  806.           (*IdChars:*)
  807.           '0'..'9', 'A'..'Z', '_', 'a'..'z', '@':
  808.                 spc:= FALSE;
  809.                 Append (GlobCh, ProcBuf, ok);
  810.                 GetChar
  811.         ELSE
  812.           EXIT
  813.         END;
  814.       END;
  815.       IF spc THEN
  816.         DelTrailingBlanks (ProcBuf);
  817.       END
  818.     END MyAppend;
  819.     
  820.     
  821.   BEGIN  (* of ProcDecl *)
  822.     IF GlobSym = ident THEN
  823.       Assign (IdentBuf, ProcBuf, ok);
  824.       
  825.       WHILE (GlobCh # '(') AND (GlobCh # ';') DO MyAppend END;
  826.       
  827.       IF GlobCh ='(' THEN
  828.         GetChar;
  829.         Append (' (', ProcBuf, ok); (* Ein Leerz. vor '(' einsetzen *)
  830.         LOOP
  831.           MyAppend;
  832.           Append (GlobCh, ProcBuf, ok);
  833.           IF (GlobCh = ':') OR (GlobCh = ';') THEN
  834.             Append (' ', ProcBuf, ok);
  835.           ELSIF GlobCh = ')' THEN
  836.             EXIT
  837.           END;
  838.           GetChar
  839.         END;
  840.         GetChar;
  841.         LOOP
  842.           MyAppend;
  843.           Append (GlobCh, ProcBuf, ok);
  844.           IF (GlobCh = ':') THEN
  845.             Append (' ', ProcBuf, ok);
  846.           END;
  847.           IF GlobCh = ';' THEN EXIT END;
  848.           GetChar
  849.         END;
  850.       END;
  851.       
  852.       PutInList;
  853.       IF FindIdent (ExIdRootPtr, FindPtr, IdentBuf) THEN
  854.         FindPtr^.ObjClass := procid;
  855.         FindPtr^.ProcHeading := ProcBuf
  856.       END;
  857.       GetSymbol;
  858.       GetSymbol
  859.     ELSE
  860.       Error (-202)
  861.     END
  862.   END ProcDecl;
  863.   
  864.   
  865.   PROCEDURE Block;
  866.   
  867.   VAR   NoMatch       : BOOLEAN;
  868.   
  869.   BEGIN
  870.     NoMatch := FALSE;
  871.     
  872.     REPEAT
  873.       CASE GlobSym OF
  874.         constid : GetSymbol;    ConstDecl |
  875.         typeid  : GetSymbol;    TypeDecl |
  876.         varid   : GetSymbol;    VarDecl |
  877.         procid  : GetSymbol;    ProcDecl
  878.       ELSE
  879.         NoMatch := TRUE
  880.       END
  881.     UNTIL (GlobSym = endid) OR NoMatch
  882.   END Block;
  883.   
  884.   
  885.   PROCEDURE ImportHdl;
  886.   (* Importliste ueberlesen *)
  887.   BEGIN
  888.     WHILE (GlobSym = fromid) OR (GlobSym = importid) DO
  889.       IF GlobSym = importid THEN
  890.         (* IMPORT Bla, Fasel; Gerd Castan 25.05.94 *)
  891.         (* lies "ident", "," nach "IMPORT" *)
  892.         WHILE GlobSym # semicolon DO GetSymbol END;
  893.         GetSymbol;
  894.         
  895.         (* Original:
  896.         (* IMPORT BlaBla; *)
  897.         GetSymbol;
  898.         IF GlobSym # ident THEN Error (-202)
  899.         ELSE
  900.           GetSymbol;
  901.           IF GlobSym # semicolon THEN Error (-202) END;
  902.           GetSymbol
  903.         END
  904.         *)
  905.       ELSE
  906.         (* FROM DingsDa IMPORT Bla, BlaBla...; *)
  907.         GetSymbol;                          (* lies "Ident" nach "FROM" *)
  908.         IF GlobSym = ident
  909.           THEN
  910.             GetSymbol;                      (* lies "IMPORT" *)
  911.             IF GlobSym = importid
  912.               THEN              (* lies "ident", "," nach "IMPORT" *)
  913.                 WHILE GlobSym # semicolon DO GetSymbol END;
  914.                 GetSymbol;
  915.             END
  916.           ELSE Error (-202)
  917.         END  (* IF GlobSym = ident *)
  918.       END  (* IF ... ELSE *)
  919.     END (* WHILE *)
  920.   END ImportHdl;
  921.   
  922.   
  923.   
  924.   PROCEDURE QualIdents;
  925.   BEGIN
  926.     WHILE GlobSym # semicolon DO
  927.       (* Exportliste nicht in die Liste aufnehmen
  928.         PutInList;
  929.       *)
  930.       GetSymbol;
  931.       IF GlobSym = comma THEN GetSymbol END
  932.     END;
  933.     GetSymbol
  934.   END QualIdents;
  935.   
  936.   
  937.   PROCEDURE ExportHdl;
  938.   BEGIN
  939.     GetSymbol;                          (* lies "QUALIFIED" oder "Ident" *)
  940.     IF GlobSym = qualid THEN GetSymbol END;  (* "ident" nach "QUALIFIED" *)
  941.     IF GlobSym = pervid THEN GetSymbol END;  (* "ident" nach "PERVASIVE" *)
  942.     QualIdents;
  943.     IF GlobSym = expid THEN ExportHdl END
  944.   END ExportHdl;
  945.   
  946.   
  947.   PROCEDURE DefModule;
  948.   BEGIN
  949.     IF GlobSym = defid
  950.       THEN
  951.         GetSymbol;                      (* lies "MODULE" *)
  952.         IF GlobSym = modid
  953.           THEN
  954.             GetSymbol;                  (* lies "Ident" nach "MODULE" *)
  955.             IF GlobSym = ident
  956.               THEN                      (* save "Ident" fuer spaeter *)
  957.                 DefModIdent := IdentBuf;
  958.                 GetSymbol;
  959.                 IF GlobSym = semicolon THEN
  960.                   GetSymbol;
  961.                   IF (GlobSym = fromid) OR
  962.                      (GlobSym = importid ) THEN ImportHdl END;
  963.                   IF GlobSym = expid THEN
  964.                     WriteString ('Exportliste wird ignoriert!');
  965.                     WriteLn;
  966.                     ExportHdl
  967.                   END;
  968.                   Block;
  969.                   IF GlobSym = endid THEN
  970.                     GetSymbol;             (* lies Module "Ident" *)
  971.                     IF (GlobSym = ident) AND
  972.                       StrEqual (UpStr (DefModIdent), UpStr (IdentBuf))
  973.                     THEN
  974.                       GetSymbol;
  975.                       IF GlobSym # period THEN Error (-201) END
  976.                     ELSE
  977.                       Error (-201)
  978.                     END
  979.                   ELSE
  980.                     Error (-201)
  981.                   END
  982.                 ELSE
  983.                   Error (-203)
  984.                 END
  985.               ELSE Error (-200)
  986.             END
  987.           ELSE Error (-200)
  988.         END
  989.       ELSE Error (-200)
  990.     END
  991.   END DefModule;
  992.   
  993.   
  994.   PROCEDURE Parse;
  995.   BEGIN
  996.     GetSymbol;
  997.     DefModule;
  998.   END Parse;
  999.   
  1000.  
  1001. PROCEDURE parsefile (REF p:ARRAY OF CHAR; d: DirEntry): BOOLEAN;
  1002.   VAR s:String;
  1003.   BEGIN
  1004.     InitNewDefMod;
  1005.     Concat (p,d.name,s,ok);
  1006.     OpenFile (s);
  1007.     ReadFile;
  1008.     Parse;
  1009.     Close (InFile);
  1010.     RETURN TRUE
  1011.   END parseFile;
  1012.  
  1013. VAR result: INTEGER; path: STRING;
  1014.  
  1015. BEGIN   (* of DMA *)
  1016.   IF Init () THEN
  1017.     LOOP
  1018.       Writeln;
  1019.       WriteString ('Filename (with wildcards): ');
  1020.       ReadString (path);
  1021.       IF Empty (path) THEN EXIT END;
  1022.       Writeln;
  1023.       DirQuery (path, FileAttrSet {}, parseFile, result)
  1024.     END;
  1025.     List
  1026.   END
  1027. END DMA.
  1028.